home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / BARNET / COMPILER / SATHER / !Sather / Library / Base / sa / misc < prev    next >
Text File  |  1996-04-17  |  3KB  |  83 lines
  1. ---------------------------> Sather 1.1 source file <--------------------------
  2. -- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
  3. -- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
  4. -- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
  5. -- the file "Doc/License" of the Sather distribution.  The license is also   --
  6. -- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
  7. --------> Please email comments to "sather-bugs@icsi.berkeley.edu". <----------
  8. -------------------------------------------------------------------
  9. abstract class $OB is
  10.    -- Just a stub.  Everything subtypes from $OB, but this may not
  11.    -- be explicitly indicated in the compiler/browser type graph
  12.    
  13. end; -- type $OB
  14. -------------------------------------------------------------------
  15. class EXT_OB is
  16.    -- External objects.
  17. end; -- class EXT_OB
  18. -------------------------------------------------------------------
  19. class CAST{T} is
  20.    -- Narrow down from $OB to type T. A useful substitute for the
  21.    -- one line typecase statement.
  22.    --   Usage:
  23.    --    a: $OB := 3;
  24.    --    b: INT := CAST{INT}::from(a);
  25.    -- 
  26.    
  27.    create: SAME is return new end;
  28.    -- Used to get the class name (won't work with void?)
  29.    
  30.    from(o: $OB): T is 
  31.       -- Cast from o:$OB "o" to be of type T.
  32.       -- Raise the exception CAST_EXC if "o" is not of type T
  33.       -- 
  34.       -- Usage:
  35.       --    a: $OB := 3;
  36.       --    b: INT := CAST{INT}::from(a);
  37.       typecase o 
  38.       when T then return o 
  39.       else raise #CAST_EXC(o,#SAME);   end;
  40.    end;
  41.    
  42. end;
  43. -------------------------------------------------------------------
  44. class CAST_EXC < $STR is
  45.    -- Exception that is raised when a CAST{T}::from call fails
  46.  
  47.    readonly attr ob: $OB;
  48.    readonly attr caster: $OB;    -- Mainly so that we can find out the 
  49.    -- class name of the cast for error reporting.
  50.    
  51.    create(ob: $OB,caster: $OB): SAME is
  52.       res ::= new;
  53.       res.ob := ob;
  54.       res.caster := caster;
  55.       return res;
  56.    end;
  57.    
  58.    str: STR is 
  59.       caster_tp::= SYS::tp(caster);
  60.       caster_name::= SYS::str_for_tp(caster_tp);
  61.       res ::= "Typecasing using:"+caster_name+" ";
  62.       if void(ob) then res := res+" attempted to typecase a void object";
  63.       else 
  64.      ob_tp ::= SYS::tp(ob);
  65.      ob_classname ::= SYS::str_for_tp(ob_tp);
  66.      res := res + " tried an invalid typecase from:"+ob_classname;
  67.       end;
  68.       return res;
  69.    end;
  70.    
  71. end;
  72. -------------------------------------------------------------------
  73. partial class ID is
  74.    -- ID is meant to be included by types that wish to provide object 
  75.    -- equality as their natural, immutable
  76.    -- identity relation
  77.       is_eq(arg:$OB):BOOL is return SYS::ob_eq(self,arg) end;
  78.       -- is_lt and hash fail for value types
  79.       is_lt(arg:$OB):BOOL is return SYS::id(self) < SYS::id(arg) end;
  80.       hash:INT is return SYS::id(self).hash end;
  81.    end;
  82. -------------------------------------------------------------------+
  83.